perm filename FEND.LSP[CMP,LSP] blob
sn#331930 filedate 1978-01-29 generic text, type T, neo UTF8
(DE %RENAME (U BOOL)
(PROG NIL
A (COND ((NULL U) (RETURN NIL)))
(%PUTPROP (CADAR U) (GET (CAAR U) (QUOTE SUBR)) (QUOTE SUBR))
(COND (BOOL (REMPROP (CAAR U) (QUOTE SUBR))))
(SETQ U (CDR U))
(GO A)))
(PUTPROP (QUOTE %PUTPROP) (GET (QUOTE PUTPROP) (QUOTE SUBR)) (QUOTE SUBR))
(%RENAME (QUOTE ((ASSOC %ASSOC) (MAP %MAP)
(MAPC %MAPC)
(MAPCAR %MAPCAR)
(MAPLIST %MAPLIST)
(READ %READ)
(REMOVE %REMOVE)
(SCAN %SCAN)))
T)
(%PUTPROP (QUOTE %REMOB) (GET (QUOTE REMOB) (QUOTE FSUBR)) (QUOTE FSUBR))
(%RENAME (QUOTE ((ERR ERROR) (GET FLAGP)
(NUMBERP DIGIT)
(PRINC PRIN1)
(REMPROP %REMPROP)))
NIL)
(%RENAME (QUOTE ((*DIF DIFFERENCE) (*GREAT GREATERP)
(*LESS LESSP)
(*QUO QUOTIENT)
(*PLUS PLUS2)
(*TIMES TIMES2)))
NIL)
(REMPROP (QUOTE DIFFERENCE) (QUOTE MACRO))
(REMPROP (QUOTE GREATERP) (QUOTE MACRO))
(REMPROP (QUOTE LESSP) (QUOTE MACRO))
(REMPROP (QUOTE QUOTIENT) (QUOTE MACRO))
(DE MAP (U V) (%MAP V U))
(DE MAPC (U V) (%MAPC V U))
(DE MAPCAR (U V) (%MAPCAR V U))
(DE MAPLIST (U V) (%MAPLIST V U))
(DE ARRAY (U)
(PROG NIL
A (COND ((NULL U) (RETURN NIL)))
(EVAL (CONS (QUOTE %ARRAY) (CONS (CAAR U) (CONS T (CDAR U)))))
(PUT (CAAR U) (QUOTE DIMENSION) (CDAR U))
(SETQ U (CDR U))
(GO A)))
(DE ARRAYP (U) (DIMENSION U))
(DE COMPRESS (U) (COND ((NUMBERP (CAR U)) (MAKNAM U)) (T (READLIST U))))
(DE CONSTANTP (U) (OR (NUMBERP U) (STRINGP U) (ARRAYP U)))
(DE DIMENSION (U)
(COND ((AND (ATOM U) (NOT (NUMBERP U))) (GET U (QUOTE DIMENSION))) (T NIL)))
(DE EJECT NIL (PRINC (ASCII 12)))
(DE EQN (M N)
(AND (NUMBERP M) (COND ((LESSP (ABS M) 1000) (EQ M N)) (T (EQUAL M N)))))
(DE ERRORSET (*U *V W) (ERRSET (EVAL *U) *V))
(DE FIXP (N)
(AND (NUMBERP N) (OR (EQ N (PLUS 0 N)) (NULL (EQ (CADR N) (QUOTE FLONUM))))))
(DE FLAG (U V)
(PROG NIL
A (COND ((NULL U) (RETURN NIL)))
(PUT (CAR U) V T)
(SETQ U (CDR U))
(GO A)))
(DE FLOAT (N) (TIMES2 N 1.0))
(DE FLOATP (N) (AND (NUMBERP N) (NOT (FIXP N))))
(DE FLUID (U)
(PROG (*X*)
A (COND ((NULL U) (RETURN NIL)))
(%PUTPROP (CAR U) (QUOTE SYMBOLIC) (QUOTE MODE))
(%PUTPROP (CAR U) T (QUOTE FLUID))
(SETQ U (CDR U))
(GO A)))
(DE FLUIDP (U) (FLAGP U (QUOTE FLUID)))
(DE GETD (U)
(PROG (X)
(SETQ X (GETL U FTYPES*))
(RETURN (COND (X (CONS (CAR X) (CADR X))) (T NIL)))))
(DE GETEL (U) (EVAL U))
(SETQ *DEFN NIL)
(DE GLOBAL (U)
(PROG (*X*)
A (COND ((NULL U) (RETURN NIL)))
(%PUTPROP (CAR U) (QUOTE SYMBOLIC) (QUOTE MODE))
(%PUTPROP (CAR U) T (QUOTE FLUID))
(COND ((AND (NULL *DEFN)
(OR (NULL (SETQ *X* (GET (CAR U) (QUOTE VALUE))))
(AND (ATOM (SETQ *X* (CDR *X*)))
(NOT (NUMBERP *X*))
(EQ (INTERN *X*) (QUOTE UNBOUND)))))
(SET (CAR U) NIL)))
(SETQ U (CDR U))
(GO A)))
(DE GLOBALP (U) NIL)
(DE IDP (U) (AND (ATOM U) (NOT (CONSTANTP U))))
(DE LITER (X)
(AND (NULL (NUMBERP X))
(OR (AND (GREATERP (SETQ X (LSH (MAKNUM (CAAR (GET X (QUOTE PNAME)))
(QUOTE FIXNUM))
(MINUS 11)))
64)
(GREATERP 111 X))
(AND (GREATERP X 116) (GREATERP 123 X)))))
(GLOBAL (QUOTE (OBLIST)))
(FLUID (QUOTE (*PI*)))
(DE MAPOBL (*PI*)
(MAPC OBLIST
(FUNCTION (LAMBDA (X) (MAPC X (FUNCTION (LAMBDA (Y) (*PI* Y))))))))
(GLOBAL (QUOTE (PAGEL*)))
(DE PAGELENGTH (U) (COND ((NULL U) PAGEL*) (T (SETQ PAGEL* U))))
(DE PAIRP (U) (NOT (ATOM U)))
(DE POSN NIL (DIFFERENCE (LINELENGTH NIL) (CHRCT)))
(DE PUT (U V W) (%PUTPROP U W V))
(GLOBAL (QUOTE (FTYPES*)))
(SETQ FTYPES* (QUOTE (EXPR FEXPR SUBR FSUBR LEXPR LSUBR MACRO NMACRO SMACRO)))
(DE PUTD (NAME TYPE BODY)
(PROG (BOOL)
(COND ((FLAGP NAME (QUOTE LOSE)) (RETURN NIL))
((MEMQ TYPE FTYPES*)
(MAPC FTYPES*
(FUNCTION (LAMBDA (X)
(COND ((GET NAME X) (PROGN (REMPROP NAME X)
(SETQ BOOL T)))))))))
(PUT NAME TYPE BODY)
(COND ((AND BOOL (NULL *DEFN))
(PROGN (LPRIM (LIST NAME (QUOTE REDEFINED)))
(REMPROP NAME (QUOTE TRACE))
(REMPROP NAME (QUOTE TRACECNT)))))
(COND ((AND *COMP (MEMQ TYPE (QUOTE (EXPR FEXPR))))
(COMPILE (LIST NAME))))
(RETURN NAME)))
(SETQ *COMP NIL)
(DE READ NIL (PROG (X) (SCANRESET) (SETQ X (%READ)) (SCANSET) (RETURN X)))
(DE REMD (U) (PROG NIL (MAPC FTYPES* (FUNCTION (LAMBDA (X) (REMPROP U X))))))
(DE REMFLAG (U V)
(PROG NIL
A (COND ((NULL U) (RETURN NIL)))
(REMPROP (CAR U) V)
(SETQ U (CDR U))
(GO A)))
(DE REMOB (L) (EVAL (CONS (QUOTE %REMOB) L)))
(DE REMPROP (U V)
((LAMBDA (X) (COND (X (PROGN (%REMPROP U V) X)) (T NIL))) (GET U V)))
(REMPROP (QUOTE REMOB) (QUOTE FSUBR))
(DE SETEL (U V) (EVAL (LIST (QUOTE STORE) U (LIST (QUOTE QUOTE) V))))
(DE SPECIAL (U) (PROGN (LPRIM (QUOTE PLEASE USE FLUID)) (FLUID U)))
(DE SPECIALP (U) (PROGN (LPRIM (QUOTE PLEASE USE FLUIDP)) (FLUIDP U)))
(DE UNSPECIAL (U) (PROGN (LPRIM (QUOTE PLEASE USE UNFLUID)) (UNFLUID U)))
(DE STRINGP (U) (AND (ATOM U) (EQ (CAR (EXPLODE U)) (QUOTE /"))))
(DE UNFLUID (U)
(PROGN (MAPC U (FUNCTION (LAMBDA (X) (REMPROP X (QUOTE MODE)))))
(REMFLAG U (QUOTE FLUID))))
(GLOBAL (QUOTE (XIFL* XIPL* XOFL* XOPL*)))
(DE OPEN (U V)
(PROG NIL
(EVAL (CONS V (CONS (MKAT U) U)))
(COND ((EQ V (QUOTE INPUT)) (SETQ XIPL* (CONS U XIPL*)))
(T (SETQ XOPL* (CONS U XOPL*))))
(RETURN U)))
(DE RDS (U)
(COND ((NULL U) (INC (SETQ XIFL* NIL) NIL))
((MEMBER U XIPL*) (PROG2 (SETQ XIFL* U) (INC (MKAT U) NIL)))
(T (REDERR (CONS (QUOTE RDS GIVEN CLOSED FILE) U)))))
(DE WRS (U)
(COND ((NULL U) (OUTC (SETQ XOFL* NIL) NIL))
((MEMBER U XOPL*) (PROG2 (SETQ XOFL* U) (OUTC (MKAT U) NIL)))
(T (REDERR (CONS (QUOTE WRS GIVEN CLOSED FILE) U)))))
(DE CLOSE (U)
(COND ((NULL U) NIL)
((MEMBER U XIPL*)
(INC (COND ((NULL (EQUAL U XIFL*)) (INC (MKAT U) NIL)) (T NIL)) T))
((MEMBER U XOPL*)
(OUTC (COND ((NULL (EQUAL U XOFL*)) (OUTC (MKAT U) NIL)) (T NIL)) T))
(T (REDERR (CONS (QUOTE CLOSE GIVEN CLOSED FILE) U)))))
(DE MKAT (U)
(PROG (Z)
(SETQ U (FLATTEN U))
(SETQ Z (LIST (QUOTE M)))
A (COND ((NULL U) (RETURN (COMPRESS Z))))
(SETQ Z (NCONC (EXPLODE (CAR U)) Z))
(SETQ U (CDR U))
(GO A)))
(DE FLATTEN (U)
(COND ((NULL U) NIL)
((ATOM U) (LIST U))
((ATOM (CAR U)) (CONS (CAR U) (FLATTEN (CDR U))))
(T (NCONC (FLATTEN (CAR U)) (FLATTEN (CDR U))))))
(DE ASSOC (U V)
(COND ((NULL V) NIL) ((EQUAL U (CAAR V)) (CAR V)) (T (ASSOC U (CDR V)))))
(DF DE (U) (PUTD (CAR U) (QUOTE EXPR) (LIST (QUOTE LAMBDA) (CADR U) (CADDR U))))
(DE DEFLIST (L V)
(COND ((NULL L) NIL)
(T (CONS (PROG2 (PUT (CAAR L) V (CADAR L)) (CAAR L))
(DEFLIST (CDR L) V)))))
(DE DELETE (U V)
(COND ((NULL V) NIL)
((EQUAL U (CAR V)) (CDR V))
(T (CONS (CAR V) (DELETE U (CDR V))))))
(DF DF (U)
(PUTD (CAR U) (QUOTE FEXPR) (LIST (QUOTE LAMBDA) (CADR U) (CADDR U))))
(DF DM (U)
(PUTD (CAR U) (QUOTE MACRO) (LIST (QUOTE LAMBDA) (CADR U) (CADDR U))))
(DE EXPAND (FORM FN)
(COND ((NULL (CDR FORM)) NIL)
((NULL (CDDR FORM)) (CADR FORM))
(T (LIST FN (CADR FORM) (CONS (CAR FORM) (CDDR FORM))))))
(DE EXPT (M N)
(PROG (P Q)
(COND ((LESSP N 0) (RETURN (QUOTIENT 1.0 (EXPT M (MINUS N)))))
((OR (EQ N 0) (EQ M 1)) (RETURN 1)))
(SETQ P 1)
A (SETQ Q (DIVIDE N 2))
(COND ((EQ (CDR Q) 0) (GO B)))
(SETQ P (TIMES M P))
(COND ((EQ (CAR Q) 0) (RETURN P)))
B (SETQ N (CAR Q))
(SETQ M (TIMES M M))
(GO A)))
(DE MAPCAN (X *PI*)
(COND ((NULL X) NIL) (T (NCONC (*PI* (CAR X)) (MAPCAN (CDR X) *PI*)))))
(DE MAPCON (X *PI*)
(COND ((NULL X) NIL) (T (NCONC (*PI* X) (MAPCON (CDR X) *PI*)))))
(DE MAX (U V) (COND ((LESSP U V) V) (T U)))
(DE MIN (U V) (COND ((GREATERP U V) V) (T U)))
(DE PAIR (U V)
(COND ((AND (NULL U) (NULL V)) NIL)
((OR (NULL U) (NULL V))
(REDERR (LIST (QUOTE MISMATCH OF ARGUMENTS) U V)))
(T (CONS (CONS (CAR U) (CAR V)) (PAIR (CDR U) (CDR V))))))
(PUTD (QUOTE PLUS) (QUOTE MACRO) (QUOTE (LAMBDA (U) (EXPAND U (QUOTE PLUS2)))))
(DE PRINT (U) (PROGN (PRIN1 U) (TERPRI)))
(DE PRIN2 (U) (PROGN (MAPC (EXPLODE U) (FUNCTION PRINC)) U))
(FLUID (QUOTE (%U %V)))
(PUTD (QUOTE PROGN) (QUOTE MACRO) (QUOTE (LAMBDA (U) (EXPAND U (QUOTE PROG2)))))
(DE SASSOC (U V *PI*)
(COND ((NULL V) (*PI*))
((EQUAL U (CAAR V)) (CAR V))
(T (SASSOC U (CDR V) *PI*))))
(DE SUBLIS (X Y)
(PROG (U)
(COND ((NULL X) (RETURN Y)))
(SETQ U X)
A (COND ((NULL U)
(RETURN (COND ((OR (ATOM Y)
(EQUAL (SETQ U (CONS (SUBLIS X (CAR Y))
(SUBLIS X (CDR Y))))
Y))
Y)
(T U))))
((EQUAL Y (CAAR U)) (RETURN (CDAR U))))
(SETQ U (CDR U))
(GO A)))
(PUTD (QUOTE TIMES)
(QUOTE MACRO)
(QUOTE (LAMBDA (U) (EXPAND U (QUOTE TIMES2)))))
65536